home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / akcl1615.lha / lsp / debug.lsp < prev    next >
Text File  |  1991-02-18  |  24KB  |  796 lines
  1. ;;Copyright William F. Schelter 1990, All Rights Reserved 
  2.  
  3.  
  4. (In-package "SYSTEM")
  5. (import 'sloop::sloop)
  6.  
  7. (eval-when (compile eval)
  8.   (proclaim '(optimize (safety 2) (space 3)))
  9.  
  10. (defmacro f (op &rest args)
  11.     `(the fixnum (,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) )))
  12.  
  13. (defmacro fb (op &rest args)
  14.     `(,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) ))
  15.  
  16.   )
  17.  
  18. ;;; Some debugging features:
  19. ;;; Search-stack :
  20. ;;; (:s "cal") or (:s 'cal) searches the stack for a frame whose function or 
  21. ;;; special form has a name containing "cal", moves there to display the local
  22. ;;; data.
  23. ;;;
  24. ;;; Break-locals :
  25. ;;; :bl displays the args and locals of the current function.
  26. ;;; (:bl 4) does this for 4 functions.
  27. ;;;
  28. ;;; (si:loc i)  accesses the local(i): slot.
  29. ;;; the *print-level* and *print-depth* are bound to *debug-print-level*
  30.  
  31. ;;; Note you must have space < 3  in your optimize proclamation, in order for
  32. ;;; the local variable names to be saved by the compiler.
  33.  
  34. ;;; With BSD You may also use the function write-debug-symbols to
  35. ;;; obtain an object file with the correct symbol information for using a
  36. ;;; c debugger, on translated lisp code.  You should have used the :debug
  37. ;;; t keyword when compiling the file.
  38.  
  39. ;;; To Do: add setf method for si:loc.
  40. ;;; add restart capability from various spots on the stack.
  41.  
  42. (defun show-break-variables (&optional (n 1))
  43.   (loop
  44.                     ;(break-current)
  45.    (dolist (v (reverse(car *break-env*)))
  46.      (format *debug-io* "~%~9a: ~s" (car v) (second v)))
  47.    (or (fb >  (incf  n -1) 0) (return (values)))
  48.    (break-previous)
  49.    ))
  50.  
  51. (defun show-environment (ihs)
  52.   (let ((lis  (vs (ihs-vs ihs))))
  53.     (if (listp lis)
  54.     (dolist (v (reverse (vs (ihs-vs ihs))))
  55.       (format *debug-io* "~%~9a: ~s" (car v) (second v))))))
  56.  
  57. (putprop :a 'show-break-variables 'break-command)
  58.  
  59. ;;make hack in compiler to remember the local variable names for the 
  60. ;;vs variables and associate it with the function name
  61.  
  62. (defun search-stack (sym &aux string)
  63.   (setq string (cond((symbolp sym)(symbol-name sym))
  64.             (t sym)))
  65.   (sloop
  66.      for ihs downfrom (ihs-top) above 2
  67.      for fun = (ihs-fun ihs) with name
  68.      do 
  69.      (cond ((compiled-function-p fun)
  70.         (setq name (compiled-function-name fun)))
  71.        ((symbolp fun ) (setq name fun))
  72.        ((and (listp fun)
  73.          (member (car fun) '(lambda lambda-block)))
  74.         (setq name (second fun)))
  75.        (t (setq name '||)))
  76.      when (search string (symbol-name name) :test 'equal)
  77.      do (return (progn (break-go ihs)(terpri) (break-locals)))
  78.      finally (format *debug-io* "~%Search for ~a failed" string)
  79.      ))
  80.  
  81. (defvar *debug-print-level* 3)
  82.  
  83. (defun break-locals (&optional (n 1)
  84.                    &aux (ihs *current-ihs*)
  85.                    (base  (ihs-vs ihs))
  86.                    (*print-level* *debug-print-level*)
  87.                    *print-circle*
  88.                    (*print-length* *debug-print-level*)
  89.                    (current-ihs *current-ihs*)
  90.                    (fun (ihs-fun ihs)) name args)
  91.   (cond ((fb > n 1)
  92.      (sloop for i below n
  93.         for ihs downfrom current-ihs above 2
  94.         do (let ((*current-ihs* ihs))
  95.          (break-locals) (terpri)(terpri)
  96.          )))
  97.     (t
  98.      (cond ((compiled-function-p fun)
  99.         (setq name (compiled-function-name fun)))
  100.            (t (setq name fun)))
  101.          (if (symbolp name)(setq args (get name 'debug)))
  102.      (let ((next (ihs-vs (f + 1 *current-ihs*))))
  103.        (cond (next
  104.           (format *debug-io* ">> ~a():" name)
  105.           (cond ((symbolp name)     
  106.              (sloop for i from base below next for j from 0
  107.                 for u = nil
  108.                 do 
  109.                 (cond ((member 0 args);;old debug info.
  110.                    (setf u (getf  args j)))
  111.                   (t (setf u (nth j args))))
  112.                 (cond (u
  113.                    (format t
  114.                        "~%Local~a(~a): ~a" j u  (vs i)))
  115.                   (t
  116.                    (format *debug-io* "~%Local(~d): ~a"
  117.                        j (vs i))))))
  118.             ((listp name)
  119.              (show-environment  ihs))
  120.             (t (format *debug-io* "~%Which case is this??")))))))))
  121.  
  122. (defun loc (&optional (n 0))
  123.   (let ((base (ihs-vs *current-ihs*)))
  124.     (unless  (and (fb >= n 0)
  125.           (fb < n (f - (ihs-vs
  126.                 (min (ihs-top) (f + 1 *current-ihs*)))
  127.                  base)))
  128.          (error "Not in current function"))
  129.     (vs (f + n base))))
  130.  
  131. (putprop :bl 'break-locals 'break-command)
  132. (putprop :s 'search-stack 'break-command)
  133.  
  134. (defvar *record-line-info* (make-hash-table :test 'eq))
  135.  
  136. (defvar *at-newline* nil)
  137.  
  138. (defvar *standard-readtable* *readtable*)
  139.  
  140. (defvar *line-info-readtable* (copy-readtable))
  141.  
  142. (defvar *left-parenthesis-reader* (get-macro-character #\( ))
  143.  
  144. (defvar *quotation-reader* (get-macro-character #\" ))
  145.  
  146. (defvar *stream-alist* nil)
  147.  
  148. (defvar *break-point-vector* (make-array 10 :fill-pointer 0 :adjustable t))
  149.  
  150. (defvar *step-next* nil)
  151.  
  152. (defvar *last-dbl-break* nil)
  153.  
  154. #-akcl
  155. (eval-when (compile eval load)
  156.  
  157. (defvar *places* '(|*mv0*| |*mv1*| |*mv2*| |*mv3*| |*mv4*| |*mv5*| |*mv6*| |*mv7*|
  158.              |*mv8*| |*mv9*|))
  159.  
  160. (defmacro set-mv (i val) `(setf ,(nth i *places*) ,val))
  161.  
  162. (defmacro mv-ref (i) (nth i *places*))
  163.   )
  164.  
  165. (defmacro mv-setq (lis form)
  166.   `(prog1 (setf ,(car lis) ,form)
  167.      ,@ (do ((v (cdr lis) (cdr v))
  168.          (i 0 (1+ i))
  169.          (res))
  170.         ((null v)(reverse res))
  171.       (push `(setf ,(car v) (mv-ref ,i)) res))))
  172.  
  173. (defmacro mv-values (&rest lis)
  174.   `(prog1 ,(car lis)
  175.      ,@ (do ((v (cdr lis) (cdr v))
  176.          (i 0 (1+ i))
  177.          (res))
  178.         ((null v)(reverse res))
  179.       (push `(set-mv ,i ,(car v)) res))))
  180.  
  181. ;;start a lisp debugger loop.   Exit it by using :step
  182.  
  183. (defun dbl ()
  184.   (break-level nil nil))
  185.  
  186. (defstruct instream stream (line 0 :type fixnum) stream-name)
  187.  
  188.  
  189. (eval-when (eval compile)
  190.  
  191. (defstruct (bkpt (:type list)) form file file-line function)
  192.   )
  193.  
  194. (defun cleanup ()
  195.   (dolist (v *stream-alist*)
  196.     (if (closedp (instream-stream v))
  197.     (setq *stream-alist* (delete v *stream-alist*)))))
  198.  
  199. (defun get-instream (str)
  200.   (or (dolist (v *stream-alist*)
  201.     (cond ((eq str (instream-stream v))
  202.            (return v))))
  203.       (car (setq *stream-alist*
  204.          (cons  (make-instream :stream str) *stream-alist*)))))
  205.  
  206. (defun newline (str ch) ch
  207.   (let ((in (get-instream str)))
  208.     (setf (instream-line in) (the fixnum (f + 1 (instream-line in)))))
  209.   ;; if the next line begins with '(', then record all cons's eg arglist )
  210.   (setq *at-newline*  (if (eql (peek-char nil str nil) #\() :all t))
  211.   (values))
  212.  
  213. (defun quotation-reader (str ch)
  214.   (let ((tem (funcall *quotation-reader* str ch))
  215.     (instr (get-instream str)))
  216.     (incf (instream-line instr) (count #\newline tem))
  217.     tem))
  218.  
  219. (defvar *old-semicolon-reader* (get-macro-character #\;))
  220.  
  221. (defun new-semi-colon-reader (str ch)
  222.   (let ((in (get-instream str))
  223.     (next (peek-char nil str nil nil)))
  224.     (setf (instream-line in) (the fixnum (f + 1 (instream-line in))))
  225.     (cond ((eql next #\!)
  226.        (read-char str)
  227.        (let* ((*readtable* *standard-readtable*)
  228.           (command (read-from-string (read-line str nil nil))))
  229.          (cond ((and (consp command)
  230.              (eq (car command) :line)
  231.              (stringp (second command))
  232.              (typep (third command) 'fixnum))
  233.             (setf (instream-stream-name in) (second command))
  234.             (setf (instream-line in) (third command))))
  235.          ))
  236.       (t    (funcall *old-semicolon-reader* str ch)))
  237.     (setq *at-newline*  (if (eql (peek-char nil str nil) #\() :all t))
  238.     (values)))
  239.  
  240. (defun setup-lineinfo ()
  241.   (set-macro-character #\newline #'newline nil *line-info-readtable*)
  242.   (set-macro-character #\; #'new-semi-colon-reader nil *line-info-readtable*)
  243.   (set-macro-character #\( 'left-parenthesis-reader nil *line-info-readtable*)
  244.   (set-macro-character #\" 'quotation-reader nil *line-info-readtable*)
  245.   
  246.   )
  247.  
  248. (defun nload (file &rest args )
  249.   (clrhash *record-line-info*)
  250.   (cleanup)
  251.   (setq file (truename file))
  252.   (setup-lineinfo)
  253.   (let ((*readtable* *line-info-readtable*))
  254.     (apply 'load file args)))
  255.  
  256. (eval-when (compile eval)
  257.  
  258. (defmacro break-data (name line) `(cons ,name ,line))
  259.   )
  260.  
  261. (defun left-parenthesis-reader (str ch &aux line(flag *at-newline*))
  262.   (if (eq *at-newline* t) (setq *at-newline* nil))
  263.   (when flag
  264.     (setq flag (get-instream str))
  265.     (setq line (instream-line flag))
  266.     )
  267.   (let ((tem (funcall *left-parenthesis-reader* str ch)))
  268.     (when flag
  269.       (setf (gethash tem *record-line-info*)
  270.         (break-data (instream-name flag)
  271.             line)))
  272.     tem))
  273.  
  274. (defvar *fun-array* (make-array 50 :fill-pointer 0 :adjustable t))
  275.  
  276. (defun walk-through (body &aux tem)
  277.   (tagbody
  278.    top
  279.    (cond ((consp body)
  280.       (when (setq tem (gethash body *record-line-info*))
  281.         ;; lines beginning with ((< u v)..)
  282.         ;; aren't eval'd but are part of a special form
  283.         (cond ((and (consp (car body))
  284.             (not (eq (caar body) 'lambda)))
  285.            (remhash body *record-line-info*)
  286.            (setf (gethash (car body) *record-line-info*)
  287.              tem))
  288.           (t (vector-push-extend (cons tem body) *fun-array*))))
  289.       (walk-through (car body))
  290.       (setq body (cdr body))
  291.       (go top))
  292.      (t nil))))
  293.  
  294. (defun compiler::compiler-def-hook (name body &aux (ar *fun-array*)
  295.                      (min most-positive-fixnum)
  296.                      (max -1))
  297.   (declare (fixnum min max))
  298.   ;;  (cond ((and (boundp '*do-it*)
  299.   ;;          (eq (car body) 'lambda-block))
  300.   ;;     (setf (cdr body) (cdr  (walk-top body)))))
  301.      
  302.   (cond ((atom body)
  303.      (remprop name 'line-info))
  304.     ((eq *readtable* *line-info-readtable*) 
  305.      (setf (fill-pointer *fun-array*) 0)
  306.      (walk-through body)
  307.      (dotimes (i (length ar))
  308.           (declare (fixnum i))
  309.           (let ((n (cdar (aref ar i))))
  310.             (declare (fixnum n))
  311.             (if (fb > n max) (setf max n))
  312.             (if (fb < n min) (setf min n))))
  313.      (cond ((fb > (length *fun-array*) 0)
  314.             (let ((new (make-array (f + (f - max min) 2)
  315.                        :initial-element :blank-line))
  316.               (old-info (get name 'line-info)))
  317.           (setf (aref new 0)
  318.             (cons (caar (aref ar 0)) min))
  319.           (setq min (f - min 1))
  320.           (dotimes (i (length ar))
  321.                (let ((y (aref ar i)))
  322.                  (setf (aref new (f - (cdar y) min))
  323.                    (cdr y))))
  324.           (setf (get name 'line-info) new)
  325.           (when
  326.               old-info
  327.             (let ((tem (get name 'break-points))
  328.               (old-begin (cdr (aref old-info 0))))
  329.               (dolist (bptno tem)
  330.             (let* ((bpt (aref *break-points* bptno))
  331.                    (fun (bkpt-function bpt))
  332.                    (li (f - (bkpt-file-line bpt) old-begin)))
  333.               (setf (aref *break-points* bptno)
  334.                 (make-break-point fun  new li))))))))
  335.            (t (let ((tem (get name 'break-points)))
  336.             (iterate-over-bkpts tem :delete)))))))
  337.  
  338. (defun instream-name (instr)
  339.   (or (instream-stream-name instr)
  340.       (stream-name (instream-stream instr))))
  341.  
  342. (eval-when (eval)
  343.  
  344. (defun stream-name (str) (namestring (pathname str)))
  345.   )
  346.  
  347. (clines "static object stream_name(str) object str;{return str->sm.sm_object1; }")
  348.  
  349. (defentry stream-name (object) (object "stream_name"))
  350. (clines "static object closedp(str) object str;{return (str->sm.sm_fp==0 ? Ct :Cnil); }")
  351.  
  352. (defentry closedp (object) (object "closedp"))
  353.  
  354. (defun find-line-in-fun (form env fun  counter &aux tem)
  355.   (setq tem (get fun 'line-info))
  356.   (if tem
  357.       (let ((ar tem))
  358.     (declare (type (array (t)) ar))
  359.     (when ar
  360.       (dotimes
  361.        (i (length ar))
  362.        (cond ((eq form (aref ar i))
  363.           (when counter
  364.             (decf (car counter))
  365.             (cond ((fb > (car counter) 0)
  366.                     ;silent
  367.                (return-from find-line-in-fun :break))))
  368.           (break-level
  369.            (setq *last-dbl-break* (make-break-point fun  ar i)) env
  370.            )
  371.           (return-from find-line-in-fun :break))))))))
  372.  
  373. ;; get the most recent function on the stack with step info.
  374.  
  375. (defun current-step-fun ( &optional (ihs (ihs-top)) )
  376.   (do ((i (1- ihs) (f - i 1)))
  377.       ((fb <=  i 0))
  378.     (let ((na (ihs-fname i)))
  379.       (if (get na 'line-info) (return na)))))
  380.  
  381. (defun init-break-points ()
  382.   (setf (fill-pointer *break-point-vector*) 0)
  383.   (setf *break-points* *break-point-vector*))
  384.  
  385. (defun step-into (&optional (n 1))
  386.   ;;FORM is the next form about to be evaluated.
  387.   (or *break-points* (init-break-points))
  388.   (setq *break-step* 'break-step-into)
  389.   :resume)
  390.  
  391. (defun step-next ( &optional (n 1))
  392.   (let ((fun (current-step-fun)))
  393.     (setq *step-next* (cons n fun))
  394.     (or *break-points* (init-break-points))
  395.     (setq *break-step* 'break-step-next)
  396.     :resume))
  397.  
  398. (defun maybe-break (form line-info fun env &aux pos)
  399.   (cond ((setq pos (position form line-info))
  400.      (setq *break-step* nil)
  401.      (or (> (length *break-points*) 0)
  402.          (setf *break-points* nil))
  403.      (break-level (make-break-point fun line-info pos) env)
  404.      t)))
  405.  
  406. ;; These following functions, when they are the value of *break-step*
  407. ;; are invoked by an inner hook in eval.   They may choose to stop
  408. ;; things.
  409.  
  410. (defun break-step-into (form env)
  411.   (let ((fun (current-step-fun)))
  412.     (let ((line-info (get fun 'line-info)))
  413.       (maybe-break form line-info fun env))))
  414.  
  415. (defun break-step-next (form env)
  416.   (let ((fun (current-step-fun)))
  417.     (cond ((eql (cdr *step-next*) fun)
  418.        (let ((line-info (get fun 'line-info)))
  419.          (maybe-break form line-info fun env))))))
  420.  
  421. (setf (get :next 'break-command) 'step-next)
  422. (setf (get :step 'break-command) 'step-into)
  423. (setf (get :loc 'break-command) 'loc)
  424.  
  425.  
  426. (defun *break-points* (form  env) 
  427.   (let ((pos(position form *break-points* :key 'car)))
  428.     (format t "Bkpt ~a:" pos)
  429.     (break-level  (aref *break-points* pos) env)))
  430.  
  431.  
  432. (defun dwim (fun)
  433.   (dolist (v (list-all-packages))
  434.     (multiple-value-bind
  435.      (sym there)
  436.      (intern (symbol-name fun) v)
  437.      (cond ((get sym 'line-info)
  438.         (return-from dwim sym))
  439.        (t (or there (unintern sym))))))
  440.   (format t "~a has no line information" fun))
  441.  
  442. (defun break-function (fun &optional (li 1)  absolute  &aux fun1)
  443.   (let ((ar (get fun 'line-info)))
  444.     (when (null ar) (setq fun1 (dwim fun))
  445.       (if fun1 (return-from break-function
  446.                 (break-function fun1 li absolute))))
  447.     (or (arrayp ar)(progn (format t "~%No line info for ~a" fun)
  448.               (return-from break-function nil)))
  449.     (let ((beg (cdr (aref ar 0))))
  450.       (if absolute (setq li (f - li beg)))
  451.       (or (and (fb >= li 1) (fb < li (length ar)))
  452.       (progn (format t "~%line out of bounds for ~a" fun))
  453.       (return-from break-function nil))
  454.       (if (eql li 1)
  455.       (let ((tem (symbol-function fun)))
  456.         (cond ((and (consp tem)
  457.             (eq (car tem) 'lambda-block)
  458.             (third tem))
  459.            (setq li 2)))))
  460.       (dotimes (i (f - (length ar) li))
  461.            (when (not (eq (aref ar i) :blank-line))
  462.          (show-break-point (insert-break-point
  463.                     (make-break-point fun ar (f + li i))))
  464.          (return-from break-function (values))))
  465.       (format t "~%Beyond code for ~a "))))
  466.  
  467. (defun insert-break-point (bpt &aux at)
  468.   (or *break-points* (init-break-points))
  469.   (setq at (or (position nil *break-points*)
  470.            (prog1 (length *break-points*)
  471.          (vector-push-extend  nil *break-points*)
  472.          )))
  473.   (let ((fun (bkpt-function bpt)))
  474.     (push at (get fun 'break-points)))
  475.   (setf (aref *break-points* at) bpt)
  476.   at)
  477.  
  478. (defun short-name (name)
  479.   (let ((Pos (position #\/ name :from-end t)))
  480.     (if pos (subseq name (f + 1 pos)) name)))
  481.  
  482. (defun show-break-point (n &aux disabled)
  483.   (let ((bpt (aref *break-points* n)))
  484.     (when bpt
  485.       (when (eq (car bpt) nil)
  486.     (setq disabled t)
  487.     (setq bpt (cdr bpt)))
  488.       (format t "Bkpt ~a:(~a line ~a)~@[(disabled)~]"
  489.           n (short-name (second bpt))
  490.           (third bpt) disabled)
  491.       (let ((fun (fourth bpt)))
  492.     (format t "(line ~a of ~a)"  (relative-line fun (nth 2 bpt))
  493.         fun
  494.         )))))
  495.  
  496. (defun iterate-over-bkpts (l action)
  497.   (dotimes (i (length *break-points*))
  498.        (if (or (member i l)
  499.            (null l))
  500.            (let ((tem (aref *break-points* i)))
  501.          (setf (aref *break-points* i)
  502.                (case action
  503.              (:delete
  504.               (if tem (setf (get (bkpt-function tem) 'break-points)
  505.                     (delete i (get (bkpt-function tem) 'break-points))))
  506.               nil)
  507.              (:enable
  508.               (if (eq (car tem) nil) (cdr tem) nil))
  509.              (:disable
  510.               (if (and tem (not (eq (car tem) nil)))
  511.                   (cons nil tem)
  512.                 tem))
  513.              (:show
  514.               (when tem (show-break-point i)
  515.                 (terpri))
  516.               tem
  517.               )))))))
  518.  
  519. (setf (get :info 'break-command)
  520.       '(lambda (type)
  521.      (case type
  522.        (:bkpt  (iterate-over-bkpts nil :show))
  523.        (otherwise
  524.         (format t "usage: :info :bkpt -- show breakpoints")
  525.         ))))
  526. (setf (get :delete 'break-command)
  527.       '(lambda (&rest l) (iterate-over-bkpts l :delete)(values)))
  528. (setf (get :disable 'break-command)
  529.       '(lambda (&rest l) (iterate-over-bkpts l :disable)(values)))
  530. (setf (get :enable 'break-command)
  531.       '(lambda (&rest l) (iterate-over-bkpts l :enable)(values)))
  532. (setf (get :break 'break-command)
  533.       '(lambda (&rest l)
  534.      (print l)
  535.      (cond (l
  536.         (apply 'si::break-function l))
  537.            (*last-dbl-break*
  538.         (let ((fun  (nth 3 *last-dbl-break*)))
  539.           (si::break-function fun (nth 2 *last-dbl-break*) t))))))
  540.  
  541. (setf (get :fr 'break-command)
  542.       '(lambda (&rest l )
  543.      (dbl-up (or (car l) 0) *ihs-top*)
  544.      (values)))
  545.  
  546. (setf (get :up 'break-command)
  547.       '(lambda (&rest l )
  548.      (dbl-up (or (car l) 1) *current-ihs*)
  549.      (values)))
  550.  
  551. (setf (get :down 'break-command)
  552.       '(lambda (&rest l )
  553.      (dbl-up ( - (or (car l) 1)) *current-ihs*)
  554.      (values)))
  555.  
  556. ;; in other common lisps this should be a string output stream.
  557.  
  558. (defvar *display-string*
  559.   (make-array 100 :element-type 'string-char :fill-pointer 0 :adjustable t))
  560.  
  561. (defun display-env (n env)
  562.   (do ((v (reverse env) (cdr v)))
  563.       ((or (not (consp v)) (fb > (fill-pointer *display-string*) n)))
  564.     (or (and (consp (car v))
  565.          (listp (cdar v)))
  566.     (return))
  567.     (format *display-string* "~s=~s~@[,~]" (caar v) (cadar v) (cdr v))))
  568.  
  569. (defun apply-display-fun (display-fun  n lis)  
  570.   (let ((*print-length* *debug-print-level*)
  571.     (*print-level* *debug-print-level*)
  572.     (*print-pretty* nil)
  573.     (*PRINT-CASE* :downcase)
  574.     (*print-circle* t)
  575.     )
  576.     (setf (fill-pointer *display-string*) 0)
  577.     (format *display-string* "{")
  578.     (funcall display-fun n lis)
  579.     (when (fb > (fill-pointer *display-string*) n)
  580.       (setf (fill-pointer *display-string*) n)
  581.       (format *display-string* "..."))
  582.  
  583.     (format *display-string* "}")
  584.     )
  585.   *display-string*
  586.   )
  587.  
  588. (setf (get :bt 'break-command) 'dbl-backtrace)
  589. (setf (get '*break-points* 'dbl-invisible) t)
  590.  
  591. (defun get-line-of-form (form line-info)
  592.   (let ((pos (position form line-info)))
  593.     (if pos (f + pos (cdr (aref line-info 0))))))
  594.  
  595. (defun get-next-visible-fun (ihs)
  596.   (do ((j  ihs (f - j 1)))
  597.       ((fb < j *ihs-base*)
  598.        (mv-values nil j))
  599.     (let
  600.     ((na  (ihs-fname j)))
  601.       (cond ((special-form-p na))
  602.         ((get na 'dbl-invisible))
  603.         ((fboundp na)(return (mv-values na j)))))))
  604.  
  605. (defun dbl-what-frame (ihs &aux (j *ihs-top*) (i 0) na)
  606.   (declare (fixnum ihs j i))
  607.   (loop
  608.    (mv-setq (na j)   (get-next-visible-fun j))
  609.    (cond ((fb <= j ihs) (return i)))
  610.    (setq i (f + i 1))
  611.    (setq j (f -  j 1))))
  612.  
  613. (defun dbl-up (n ihs &aux m fun line file env )
  614.   (setq m (dbl-what-frame ihs))
  615.   (cond ((fb >= n 0)
  616.      (mv-setq (*current-ihs*  n  fun line file env)
  617.           (nth-stack-frame n ihs))
  618.      (set-env)
  619.      (print-stack-frame (f + m n) t *current-ihs* fun line file env))
  620.     (t (setq n (f + m n))
  621.        (or (fb >= n 0) (setq n 0))
  622.        (dbl-up n *ihs-top*))))
  623.     
  624. (dolist (v '( break-level universal-error-handler terminal-interrupt
  625.               break-level   evalhook find-line-in-fun))
  626.   (setf (get v 'dbl-invisible) t))
  627.  
  628. (defun next-stack-frame (ihs  &aux line-info li i k na)
  629.   (cond
  630.    ((fb < ihs *ihs-base*) (mv-values nil nil nil nil nil ))
  631.    (t (let (fun)
  632.     ;; next lower visible ihs
  633.     (mv-setq (fun i) (get-next-visible-fun  ihs))
  634.     (setq na fun)
  635.     (cond
  636.      ((and
  637.        (setq line-info (get fun 'line-info))
  638.        (do ((j (f + ihs 1) (f - j 1))
  639.         (form ))
  640.            ((<= j i) nil)
  641.          (setq form (ihs-fun j))
  642.          (cond ((setq li (get-line-of-form (ihs-fun j) line-info))
  643.             (return-from next-stack-frame 
  644.                  (mv-values
  645.                   i fun li
  646.                   ;; filename
  647.                   (car (aref line-info 0))
  648.                   ;;environment
  649.                   (list (vs (setq k (ihs-vs j)))
  650.                     (vs (1+ k))
  651.                     (vs (+ k 2)))
  652.                   )))))))
  653.      ((special-form-p na) nil)
  654.      ((get na 'dbl-invisible))
  655.      ((fboundp na)
  656.       (mv-values i na nil nil
  657.              (if (ihs-not-interpreted-env i)
  658.              nil
  659.                (let ((i (ihs-vs i)))
  660.              (list (vs i) (vs (1+ i)) (vs (f + i 2))))))))
  661.     ))))
  662.  
  663. (defun nth-stack-frame (n &optional (ihs *ihs-top*)
  664.               &aux  name line file env next)
  665.   (or (fb >= n 0) (setq n 0))
  666.   (dotimes (i (f + n 1))
  667.        (setq next (next-stack-frame ihs))
  668.        (cond (next
  669.           (mv-setq (ihs name line file env) next)
  670.           (setq ihs (f - next 1)))
  671.          (t (return (setq n (f - i 1))))))
  672.   
  673.   (setq ihs (f + ihs 1) name (ihs-fname ihs))
  674.   (mv-values ihs n name line file env ))
  675.  
  676. (defun dbl-backtrace (&optional (m 1000) (ihs *ihs-top*) &aux fun  file
  677.                 line env (i 0))
  678.   (loop
  679.    (mv-setq  (ihs fun line file  env)  (next-stack-frame ihs))
  680.    (or fun (return nil))
  681.    (print-stack-frame i nil ihs fun line file env)
  682.    (incf i)
  683.    (cond ((fb >= i m) (return (values))))
  684.    (setq ihs (f - ihs 1))
  685.    )
  686.   (values))
  687.  
  688. (defun display-compiled-env ( plength ihs &aux
  689.                       (base (ihs-vs ihs))
  690.                       (end (min (ihs-vs (1+ ihs)) (vs-top))))
  691.   (format *display-string* "")
  692.   (do ((i base )
  693.        (v (get (ihs-fname ihs) 'debug) (cdr v)))
  694.       ((or (fb >= i end)(fb > (fill-pointer *display-string*) plength)))
  695.     (format *display-string* "~a~@[~d~]=~s~@[,~]"
  696.         (or (car v)  'loc) (if (not (car v)) (f - i base)) (vs i)
  697.         (fb < (setq i (f + i 1)) end)))
  698.   )
  699.  
  700. (defun computing-args-p (ihs)
  701.   ;; When running interpreted we want a line like
  702.   ;; (list joe jane) to get recorded in the invocation
  703.   ;; history while joe and jane are being evaluated,
  704.   ;; even though list has not yet been invoked.   We put
  705.   ;; it in the history, but with the previous lexical environment.
  706.   (and (consp (ihs-fun ihs))
  707.        (> ihs 3)
  708.        (not (member (car (ihs-fun ihs)) '(lambda-block lambda)))
  709.        ;(<= (ihs-vs ihs) (ihs-vs (- ihs 1)))
  710.        )
  711.   )
  712.  
  713.  
  714. (defun print-stack-frame (i auto-display ihs fun &optional line file env)
  715.   (when (and auto-display line)
  716.     (format *debug-io* "~a:~a:0:beg~%" file line))
  717.   (let  ((computing-args (computing-args-p ihs)))
  718.     (format *debug-io* "~&#~d  ~@[~a~] ~a ~@[~a~] " i
  719.         (and computing-args "Computing args for ")
  720.         fun
  721.         (if (not (ihs-not-interpreted-env ihs))
  722.         (apply-display-fun 'display-env  80
  723.                    (car (vs (ihs-vs ihs))))
  724.           (apply-display-fun 'display-compiled-env 80 ihs)))
  725.     (if file (format *debug-io* "(~a line ~a)" file line))
  726.     (format *debug-io* "[ihs=~a]"  ihs)
  727.     ))
  728.  
  729. (defun make-break-point (fun ar i)
  730.   (list                    ;make-bkpt    ;:form
  731.    (aref ar i)
  732.                     ;:file
  733.    (car (aref ar 0))
  734.                     ;:file-line
  735.    (f + (cdr (aref  ar 0)) i)
  736.                     ;:function
  737.    fun)
  738.   )
  739.  
  740. (defun relative-line (fun l)
  741.   (let ((info (get fun 'line-info)))
  742.     (if info (f - l (cdr (aref info 0)))
  743.       0)))
  744.  
  745. (defvar *step-display* nil)
  746.  
  747. (defvar *null-io* (make-broadcast-stream))
  748. ;; should really use serror to evaluate this inside.
  749. ;; rather than just quietening it.   It prints a long stack
  750. ;; which is time consuming.
  751.  
  752. (defun safe-eval (form env &aux *break-enable*)
  753.   (let ((*error-output* *null-io*)
  754.     (*debug-io* *null-io*))
  755.     (cond ((symbolp form)
  756.        (unless (or (boundp form)
  757.                (assoc form (car env)))
  758.            (return-from safe-eval :<error>))))
  759.     (multiple-value-bind (er val)
  760.              (si::error-set
  761.               `(evalhook ',form nil nil ',env))
  762.              (if er :<error> val))))
  763.  
  764. (defvar *no-prompt* nil)
  765.  
  766. (defun set-back (at env &aux (i *current-ihs*))
  767.   (setq *no-prompt* nil)
  768.   (setq *current-ihs* i)
  769.   (cond (env   (setq *break-env* env))
  770.     (t (list   (vs (ihs-vs i)))))
  771.   
  772.   (when at
  773.     (format *debug-io* "~a:~a:0:beg~%" (second at) (third at))
  774.     (format *debug-io* "(~a line ~a) "
  775.         (second at)  (third at))
  776.     )
  777.   (dolist (v *step-display*)
  778.     (let ((res (safe-eval v env)))
  779.       (or (eq res :<error>)
  780.       (format t "(~s=~s)" v res)))))
  781.  
  782.  
  783. (eval-when (load eval)
  784.   (pushnew :sdebug *features* )
  785.                     ;(use-fast-links nil)
  786.   )
  787.  
  788.  
  789.  
  790.  
  791.  
  792.  
  793.  
  794.  
  795.  
  796.